{- This is an evaluator for CVML, a purely stack-based virtual machine language 
  http://cvml.googlecode.com -}
  
{- A data type that represents the different operations that 
	we can perform in this language -}
	
data Instruction = 
	LitInt Int
	| LitSub [Instruction]
	| LitBool Bool
	| Dup
	| Pop
	| Swap
	| If
	| Dip
	| Zero
	| Succ
	| Apply 
	| PApply
	| Get Int
	| Set Int

{- The different kinds of values that can occur on the stack -}	
data Value = 
	Int Int
	| Bool Bool
	| Sub [Instruction]

{- Allow Haskell to display the contents of the different value types -}
showVal :: Value -> String
showVal (Int n) = show n
showVal (Bool True) = "true"
showVal (Bool False) = "false"
showVal (Sub xs) = "[subroutine]"

{- To allows Haskell to show a Value you have to make it into a member of the class 
	Show, and define its "show" method as showVal -}
instance Show Value where show = showVal
	
{- Get a value from a list using an index -}
getat n xs =
	xs !! n 

{- Set a value in a list using an index -}
setat n x xs =
	take n xs ++ [x] ++ drop n xs
	
{- This is the type declaration of the evaluator function.
	 It take a list of values (the stack) and a 
	 list of instructions (the program) and 
	 returns a list of values (a new stack) -}		
eval :: [Value] -> [Instruction] -> [Value] 

{- The default implementation of eval, think of it as a 
	base case. When there are no other instructions, the 
	result is a stack. All other eval calls are recursive. -}
eval s [] =
	s
	
{- Duplicate top item on the stack -}
eval (x : s) (Dup : p) =
	eval (x : (x : s)) p

{- Remove top item on the stack -} 	
eval (x : s) (Pop : p) =
	eval s p
	
{- Push a literal (constant) integer onto the stack  -}
eval s (LitInt x : p) =
	eval (Int x : s) p

{- Push a literal (constant) boolean onto the stack  -}
eval s (LitBool b : p) =
	eval (Bool b : s) p

{- Push a literal (constant) function onto the stack  -}
eval s (LitSub f : p) =
	eval (Sub f : s) p

{- Swap top two items on the stack -}
eval (x : y : s) (Swap : p) =
	eval (y : x : s) p

{- Evaluate a function that is on the stack -}
eval (Sub f : s) (Apply : p) =
	eval (eval s f) p

{- Evaluate a function that is on the stack,
	but temporarily remove the next item on the stack -}	
eval (Sub f : x : s) (Dip : p) =
	eval (x : (eval s f)) p	

{- Perform partial application: bind an integer on the stack
	to a function on the top of the stack -}
eval (Int x : Sub f : s) (PApply : p) =
	eval (Sub (LitInt x : f) : s) p

{- Perform partial application: bind a boolean on the stack
	to a function on the top of the stack -}
eval (Bool x : Sub f : s) (PApply : p) =
	eval (Sub (LitBool x : f) : s) p
	
{- Perform partial application: bind a function on the stack
	to a function on the top of the stack -}
eval (Sub x : Sub f : s) (PApply : p) =
	eval (Sub (LitSub x : f) : s) p

{- Conditional execution of one of two functions on the stack -}
eval (Sub f : Sub g : Bool b : s) (If : p) =
	if b 
		then eval (eval s g) p
		else eval (eval s f) p
		
{- Get a copy of a value on the stack at a particular depth -}
eval (s) (Get n : p) =
	eval (getat n s : s) p
	
{- Overwrites the value on the stack at a particular depth -}
eval (x : s) (Set n : p) =
	eval (setat n x s) p
	
{- Increment the top value on the stack -}
eval (Int x : s) (Inc : p) =
	eval (succ x : s) p
	
{- Decrement the top value on the stack -}
eval (Int x : s) (Inc : p) =
	eval (pred x : s) p
	